home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / cl / pprint / initialize.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  6KB  |  110 lines
  1. ;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
  2. ;;; Cambridge, Massachusetts.
  3.  
  4. (in-package "XP")
  5.  
  6. (setq *IPD* (make-pprint-dispatch))
  7.  
  8. (set-pprint-dispatch+ '(satisfies function-call-p) #'fn-call '(-5) *IPD*)
  9. (set-pprint-dispatch+ 'cons #'pprint-fill '(-10) *IPD*)
  10. (set-pprint-dispatch+ '(cons (member defstruct)) #'block-like '(0) *IPD*)
  11. (set-pprint-dispatch+ '(cons (member block)) #'block-like '(0) *IPD*) 
  12. (set-pprint-dispatch+ '(cons (member case)) #'block-like '(0) *IPD*) 
  13. (set-pprint-dispatch+ '(cons (member catch)) #'block-like '(0) *IPD*) 
  14. (set-pprint-dispatch+ '(cons (member ccase)) #'block-like '(0) *IPD*) 
  15. (set-pprint-dispatch+ '(cons (member compiler-let)) #'let-print '(0) *IPD*)
  16. (set-pprint-dispatch+ '(cons (member cond)) #'cond-print '(0) *IPD*)
  17. (set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*) 
  18. (set-pprint-dispatch+ '(cons (member defconstant)) #'defun-like '(0) *IPD*)
  19. (set-pprint-dispatch+ '(cons (member define-setf-method)) #'defun-like '(0) *IPD*) 
  20. (set-pprint-dispatch+ '(cons (member defmacro)) #'defun-like '(0) *IPD*) 
  21. (set-pprint-dispatch+ '(cons (member define-modify-macro)) #'dmm-print '(0) *IPD*)
  22. (set-pprint-dispatch+ '(cons (member defparameter)) #'defun-like '(0) *IPD*) 
  23. (set-pprint-dispatch+ '(cons (member defsetf)) #'defsetf-print '(0) *IPD*)
  24. (set-pprint-dispatch+ '(cons (member define-setf-method)) #'defun-like '(0) *IPD*) 
  25. (set-pprint-dispatch+ '(cons (member lisp:defstruct)) #'block-like '(0) *IPD*) 
  26. (set-pprint-dispatch+ '(cons (member deftype)) #'defun-like '(0) *IPD*) 
  27. (set-pprint-dispatch+ '(cons (member defun)) #'defun-like '(0) *IPD*) 
  28. (set-pprint-dispatch+ '(cons (member defvar)) #'defun-like '(0) *IPD*) 
  29. (set-pprint-dispatch+ '(cons (member do)) #'do-print '(0) *IPD*)
  30. (set-pprint-dispatch+ '(cons (member do*)) #'do-print '(0) *IPD*) 
  31. (set-pprint-dispatch+ '(cons (member do-all-symbols)) #'block-like '(0) *IPD*) 
  32. (set-pprint-dispatch+ '(cons (member do-external-symbols)) #'block-like '(0) *IPD*) 
  33. (set-pprint-dispatch+ '(cons (member do-symbols)) #'block-like '(0) *IPD*) 
  34. (set-pprint-dispatch+ '(cons (member dolist)) #'block-like '(0) *IPD*) 
  35. (set-pprint-dispatch+ '(cons (member dotimes)) #'block-like '(0) *IPD*) 
  36. (set-pprint-dispatch+ '(cons (member ecase)) #'block-like '(0) *IPD*) 
  37. (set-pprint-dispatch+ '(cons (member etypecase)) #'block-like '(0) *IPD*) 
  38. (set-pprint-dispatch+ '(cons (member eval-when)) #'block-like '(0) *IPD*) 
  39. (set-pprint-dispatch+ '(cons (member flet)) #'flet-print '(0) *IPD*)
  40. (set-pprint-dispatch+ '(cons (member function)) #'function-print '(0) *IPD*)
  41. (set-pprint-dispatch+ '(cons (member labels)) #'flet-print '(0) *IPD*) 
  42. (set-pprint-dispatch+ '(cons (member lambda)) #'block-like '(0) *IPD*) 
  43. (set-pprint-dispatch+ '(cons (member let)) #'let-print '(0) *IPD*)
  44. (set-pprint-dispatch+ '(cons (member let*)) #'let-print '(0) *IPD*)
  45. (set-pprint-dispatch+ '(cons (member locally)) #'block-like '(0) *IPD*)
  46. (set-pprint-dispatch+ '(cons (member loop)) #'pretty-loop '(0) *IPD*)
  47. (set-pprint-dispatch+ '(cons (member macrolet)) #'flet-print '(0) *IPD*) 
  48. (set-pprint-dispatch+ '(cons (member multiple-value-bind)) #'mvb-print '(0) *IPD*)
  49. (set-pprint-dispatch+ '(cons (member multiple-value-setq)) #'block-like '(0) *IPD*) 
  50. (set-pprint-dispatch+ '(cons (member prog)) #'prog-print '(0) *IPD*)
  51. (set-pprint-dispatch+ '(cons (member prog*)) #'prog-print '(0) *IPD*)
  52. (set-pprint-dispatch+ '(cons (member progv)) #'defun-like '(0) *IPD*)
  53. (set-pprint-dispatch+ '(cons (member psetf)) #'setq-print '(0) *IPD*)
  54. (set-pprint-dispatch+ '(cons (member psetq)) #'setq-print '(0) *IPD*)
  55. (set-pprint-dispatch+ '(cons (member quote)) #'quote-print '(0) *IPD*)
  56. (set-pprint-dispatch+ '(cons (member return-from)) #'block-like '(0) *IPD*)
  57. (set-pprint-dispatch+ '(cons (member setf)) #'setq-print '(0) *IPD*)
  58. (set-pprint-dispatch+ '(cons (member setq)) #'setq-print '(0) *IPD*)
  59. (set-pprint-dispatch+ '(cons (member tagbody)) #'tagbody-print '(0) *IPD*)
  60. (set-pprint-dispatch+ '(cons (member throw)) #'block-like '(0) *IPD*) 
  61. (set-pprint-dispatch+ '(cons (member typecase)) #'block-like '(0) *IPD*) 
  62. (set-pprint-dispatch+ '(cons (member unless)) #'block-like '(0) *IPD*) 
  63. (set-pprint-dispatch+ '(cons (member unwind-protect)) #'up-print '(0) *IPD*)
  64. (set-pprint-dispatch+ '(cons (member when)) #'block-like '(0) *IPD*) 
  65. (set-pprint-dispatch+ '(cons (member with-input-from-string)) #'block-like '(0) *IPD*) 
  66. (set-pprint-dispatch+ '(cons (member with-open-file)) #'block-like '(0) *IPD*)
  67. (set-pprint-dispatch+ '(cons (member with-open-stream)) #'block-like '(0) *IPD*) 
  68. (set-pprint-dispatch+ '(cons (member with-output-to-string)) #'block-like '(0) *IPD*) 
  69.  
  70. (set-pprint-dispatch+ '(cons (member lisp::backquote))
  71.               #'backquote-print '(0) *IPD*)
  72.  
  73. (set-pprint-dispatch+ `(cons (member ,lisp::*comma*))
  74.               #'comma-print '(0) *IPD*)
  75.  
  76. (set-pprint-dispatch+ `(cons (member ,lisp::*comma-atsign*))
  77.               #'comma-atsign-print '(0) *IPD*)
  78.  
  79. (set-pprint-dispatch+ `(cons (member ,lisp::*comma-dot*))
  80.               #'comma-dot-print '(0) *IPD*)
  81.  
  82. (defun pprint-dispatch-print (xp table)
  83.   (declare (ignore level))
  84.   (let ((stuff (copy-list (others table))))
  85.     (maphash #'(lambda (key val) (declare (ignore key))
  86.                (push val stuff))
  87.          (conses-with-cars table))
  88.     (maphash #'(lambda (key val) (declare (ignore key))
  89.                (push val stuff))
  90.          (structures table))
  91.     (setq stuff (sort stuff #'priority-> :key #'(lambda (x) (car (full-spec x)))))
  92.     (pprint-logical-block (xp stuff :prefix "#<" :suffix ">")
  93.               (format xp (formatter "pprint dispatch table containing ~A entries: ")
  94.                   (length stuff))
  95.               (loop (pprint-exit-if-list-exhausted)
  96.                 (let ((entry (pprint-pop)))
  97.                   (format xp (formatter "~{~_P=~4D ~W~} F=~W ")
  98.                       (full-spec entry) (fn entry)))))))
  99.  
  100. (setf (get 'pprint-dispatch 'structure-printer) #'pprint-dispatch-print)
  101.  
  102. (set-pprint-dispatch+ 'pprint-dispatch #'pprint-dispatch-print '(0) *IPD*) 
  103.  
  104. ;;; Symbolics only stuff used to be here
  105.  
  106.                     ;so only happens first time is loaded.
  107. (when (eq *print-pprint-dispatch* T)
  108.   (setq *print-pprint-dispatch* (copy-pprint-dispatch nil)))
  109.  
  110.